home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / emacs / 19.22 / lisp / edmacro.el < prev    next >
Lisp/Scheme  |  1993-09-20  |  25KB  |  695 lines
  1. ;;; edmacro.el --- keyboard macro editor
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Dave Gillespie <daveg@synaptics.com>
  6. ;; Maintainer: Dave Gillespie <daveg@synaptics.com>
  7. ;; Version: 2.01
  8. ;; Keywords: abbrev
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;;; Usage:
  29. ;;
  30. ;; The `C-x C-k' (`edit-kbd-macro') command edits a keyboard macro
  31. ;; in a special buffer.  It prompts you to type a key sequence,
  32. ;; which should be one of:
  33. ;;
  34. ;;  * RET or `C-x e' (call-last-kbd-macro), to edit the most 
  35. ;;    recently defined keyboard macro.
  36. ;;
  37. ;;  * `M-x' followed by a command name, to edit a named command
  38. ;;    whose definition is a keyboard macro.
  39. ;;
  40. ;;  * `C-h l' (view-lossage), to edit the 100 most recent keystrokes
  41. ;;    and install them as the "current" macro.
  42. ;;
  43. ;;  * any key sequence whose definition is a keyboard macro.
  44. ;;
  45. ;; This file includes a version of `insert-kbd-macro' that uses the
  46. ;; more readable format defined by these routines.
  47. ;;
  48. ;; Also, the `read-kbd-macro' command parses the region as
  49. ;; a keyboard macro, and installs it as the "current" macro.
  50. ;; This and `format-kbd-macro' can also be called directly as
  51. ;; Lisp functions.
  52.  
  53. ;; Type `C-h m', or see the documentation for `edmacro-mode' below,
  54. ;; for information about the format of written keyboard macros.
  55.  
  56. ;; `edit-kbd-macro' formats the macro with one command per line,
  57. ;; including the command names as comments on the right.  If the
  58. ;; formatter gets confused about which keymap was used for the
  59. ;; characters, the command-name comments will be wrong but that
  60. ;; won't hurt anything.
  61.  
  62. ;; With a prefix argument, `edit-kbd-macro' will format the
  63. ;; macro in a more concise way that omits the comments.
  64.  
  65. ;; This package requires GNU Emacs 19 or later, and daveg's CL
  66. ;; package 2.02 or later.  (CL 2.02 comes standard starting with
  67. ;; Emacs 19.18.)  This package does not work with Emacs 18 or
  68. ;; Lucid Emacs.
  69.  
  70. ;;; Code:
  71.  
  72. (require 'cl)
  73.  
  74. ;;; The user-level commands for editing macros.
  75.  
  76. ;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro)
  77. (define-key ctl-x-map "\C-k" 'edit-kbd-macro)
  78.  
  79. ;;;###autoload
  80. (defvar edmacro-eight-bits nil
  81.   "*Non-nil if edit-kbd-macro should leave 8-bit characters intact.
  82. Default nil means to write characters above \\177 in octal notation.")
  83.  
  84. (defvar edmacro-mode-map nil)
  85. (unless edmacro-mode-map
  86.   (setq edmacro-mode-map (make-sparse-keymap))
  87.   (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit)
  88.   (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key))
  89.  
  90. ;;;###autoload
  91. (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
  92.   "Edit a keyboard macro.
  93. At the prompt, type any key sequence which is bound to a keyboard macro.
  94. Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit
  95. the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by
  96. its command name.
  97. With a prefix argument, format the macro in a more concise way."
  98.   (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP")
  99.   (when keys
  100.     (let ((cmd (if (arrayp keys) (key-binding keys) keys))
  101.       (mac nil))
  102.       (cond (store-hook
  103.          (setq mac keys)
  104.          (setq cmd nil))
  105.         ((or (eq cmd 'call-last-kbd-macro)
  106.          (member keys '("\r" [return])))
  107.          (or last-kbd-macro
  108.          (y-or-n-p "No keyboard macro defined.  Create one? ")
  109.          (keyboard-quit))
  110.          (setq mac (or last-kbd-macro ""))
  111.          (setq cmd 'last-kbd-macro))
  112.         ((eq cmd 'execute-extended-command)
  113.          (setq cmd (read-command "Name of keyboard macro to edit: "))
  114.          (setq mac (symbol-function cmd)))
  115.         ((eq cmd 'view-lossage)
  116.          (setq mac (recent-keys))
  117.          (setq cmd 'last-kbd-macro))
  118.         ((symbolp cmd)
  119.          (setq mac (symbol-function cmd)))
  120.         (t
  121.          (setq mac cmd)
  122.          (setq cmd nil)))
  123.       (unless (arrayp mac)
  124.     (error "Not a keyboard macro: %s" cmd))
  125.       (message "Formatting keyboard macro...")
  126.       (let* ((oldbuf (current-buffer))
  127.          (mmac (edmacro-fix-menu-commands mac))
  128.          (fmt (edmacro-format-keys mmac 1))
  129.          (fmtv (edmacro-format-keys mmac (not prefix)))
  130.          (buf (get-buffer-create "*Edit Macro*")))
  131.     (message "Formatting keyboard macro...done")
  132.     (switch-to-buffer buf)
  133.     (kill-all-local-variables)
  134.     (use-local-map edmacro-mode-map)
  135.     (setq buffer-read-only nil)
  136.     (setq major-mode 'edmacro-mode)
  137.     (setq mode-name "Edit Macro")
  138.     (set (make-local-variable 'edmacro-original-buffer) oldbuf)
  139.     (set (make-local-variable 'edmacro-finish-hook) finish-hook)
  140.     (set (make-local-variable 'edmacro-store-hook) store-hook)
  141.     (erase-buffer)
  142.     (insert ";; Keyboard Macro Editor.  Press C-c C-c to finish; "
  143.         "press C-x k RET to cancel.\n")
  144.     (insert ";; Original keys: " fmt "\n")
  145.     (unless store-hook
  146.       (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
  147.       (let ((keys (where-is-internal (or cmd mac) nil)))
  148.         (if keys
  149.         (while keys
  150.           (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n"))
  151.           (insert "Key: none\n"))))
  152.     (insert "\nMacro:\n\n")
  153.     (save-excursion
  154.       (insert fmtv "\n"))
  155.     (recenter '(4))
  156.     (when (eq mac mmac)
  157.       (set-buffer-modified-p nil))
  158.     (run-hooks 'edmacro-format-hook)))))
  159.  
  160. ;;; The next two commands are provided for convenience and backward
  161. ;;; compatibility.
  162.  
  163. ;;;###autoload
  164. (defun edit-last-kbd-macro (&optional prefix)
  165.   "Edit the most recently defined keyboard macro."
  166.   (interactive "P")
  167.   (edit-kbd-macro 'call-last-kbd-macro prefix))
  168.  
  169. ;;;###autoload
  170. (defun edit-named-kbd-macro (&optional prefix)
  171.   "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'."
  172.   (interactive "P")
  173.   (edit-kbd-macro 'execute-extended-command prefix))
  174.  
  175. ;;;###autoload
  176. (defun read-kbd-macro (start &optional end)
  177.   "Read the region as a keyboard macro definition.
  178. The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\".
  179. See documentation for `edmacro-mode' for details.
  180. Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored.
  181. The resulting macro is installed as the \"current\" keyboard macro.
  182.  
  183. In Lisp, may also be called with a single STRING argument in which case
  184. the result is returned rather than being installed as the current macro.
  185. The result will be a string if possible, otherwise an event vector.
  186. Second argument NEED-VECTOR means to return an event vector always."
  187.   (interactive "r")
  188.   (if (stringp start)
  189.       (edmacro-parse-keys start end)
  190.     (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
  191.  
  192. ;;;###autoload
  193. (defun format-kbd-macro (&optional macro verbose)
  194.   "Return the keyboard macro MACRO as a human-readable string.
  195. This string is suitable for passing to `read-kbd-macro'.
  196. Second argument VERBOSE means to put one command per line with comments.
  197. If VERBOSE is `1', put everything on one line.  If VERBOSE is omitted
  198. or nil, use a compact 80-column format."
  199.   (and macro (symbolp macro) (setq macro (symbol-function macro)))
  200.   (edmacro-format-keys (or macro last-kbd-macro) verbose))
  201.  
  202. ;;; Commands for *Edit Macro* buffer.
  203.  
  204. (defun edmacro-finish-edit ()
  205.   (interactive)
  206.   (unless (eq major-mode 'edmacro-mode)
  207.     (error
  208.      "This command is valid only in buffers created by `edit-kbd-macro'"))
  209.   (run-hooks 'edmacro-finish-hook)
  210.   (let ((cmd nil) (keys nil) (no-keys nil)
  211.     (top (point-min)))
  212.     (goto-char top)
  213.     (let ((case-fold-search nil))
  214.       (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)")
  215.             t)
  216.            ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
  217.             (when edmacro-store-hook
  218.               (error "\"Command\" line not allowed in this context"))
  219.             (let ((str (buffer-substring (match-beginning 1)
  220.                          (match-end 1))))
  221.               (unless (equal str "")
  222.             (setq cmd (and (not (equalp str "none"))
  223.                        (intern str)))
  224.             (and (fboundp cmd) (not (arrayp (symbol-function cmd)))
  225.                  (not (y-or-n-p
  226.                    (format "Command %s is already defined; %s"
  227.                        cmd "proceed? ")))
  228.                  (keyboard-quit))))
  229.             t)
  230.            ((looking-at "Key:\\(.*\\)$")
  231.             (when edmacro-store-hook
  232.               (error "\"Key\" line not allowed in this context"))
  233.             (let ((key (edmacro-parse-keys
  234.                 (buffer-substring (match-beginning 1)
  235.                           (match-end 1)))))
  236.               (unless (equal key "")
  237.             (if (equalp key "none")
  238.                 (setq no-keys t)
  239.               (push key keys)
  240.               (let ((b (key-binding key)))
  241.                 (and b (commandp b) (not (arrayp b))
  242.                  (or (not (fboundp b))
  243.                      (not (arrayp (symbol-function b))))
  244.                  (not (y-or-n-p
  245.                        (format "Key %s is already defined; %s"
  246.                            (edmacro-format-keys key 1)
  247.                            "proceed? ")))
  248.                  (keyboard-quit))))))
  249.             t)
  250.            ((looking-at "Macro:[ \t\n]*")
  251.             (goto-char (match-end 0))
  252.             nil)
  253.            ((eobp) nil)
  254.            (t (error "Expected a `Macro:' line")))
  255.     (forward-line 1))
  256.       (setq top (point)))
  257.     (let* ((buf (current-buffer))
  258.        (str (buffer-substring top (point-max)))
  259.        (modp (buffer-modified-p))
  260.        (obuf edmacro-original-buffer)
  261.        (store-hook edmacro-store-hook)
  262.        (finish-hook edmacro-finish-hook))
  263.       (unless (or cmd keys store-hook (equal str ""))
  264.     (error "No command name or keys specified"))
  265.       (when modp
  266.     (when (buffer-name obuf)
  267.       (set-buffer obuf))
  268.     (message "Compiling keyboard macro...")
  269.     (let ((mac (edmacro-parse-keys str)))
  270.       (message "Compiling keyboard macro...done")
  271.       (if store-hook
  272.           (funcall store-hook mac)
  273.         (when (eq cmd 'last-kbd-macro)
  274.           (setq last-kbd-macro (and (> (length mac) 0) mac))
  275.           (setq cmd nil))
  276.         (when cmd
  277.           (if (= (length mac) 0)
  278.           (fmakunbound cmd)
  279.         (fset cmd mac)))
  280.         (if no-keys
  281.         (when cmd
  282.           (loop for key in (where-is-internal cmd nil) do
  283.             (global-unset-key key)))
  284.           (when keys
  285.         (if (= (length mac) 0)
  286.             (loop for key in keys do (global-unset-key key))
  287.           (loop for key in keys do
  288.             (global-set-key key (or cmd mac)))))))))
  289.       (kill-buffer buf)
  290.       (when (buffer-name obuf)
  291.     (switch-to-buffer obuf))
  292.       (when finish-hook
  293.     (funcall finish-hook)))))
  294.  
  295. (defun edmacro-insert-key (key)
  296.   "Insert the written name of a key in the buffer."
  297.   (interactive "kKey to insert: ")
  298.   (if (bolp)
  299.       (insert (edmacro-format-keys key t) "\n")
  300.     (insert (edmacro-format-keys key) " ")))
  301.  
  302. (defun edmacro-mode ()
  303.   "\\<edmacro-mode-map>Keyboard Macro Editing mode.  Press
  304. \\[edmacro-finish-edit] to save and exit.
  305. To abort the edit, just kill this buffer with \\[kill-buffer] RET.
  306.  
  307. Press \\[edmacro-insert-key] to insert the name of any key by typing the key.
  308.  
  309. The editing buffer contains a \"Command:\" line and any number of
  310. \"Key:\" lines at the top.  These are followed by a \"Macro:\" line
  311. and the macro itself as spelled-out keystrokes: `C-x C-f foo RET'.
  312.  
  313. The \"Command:\" line specifies the command name to which the macro
  314. is bound, or \"none\" for no command name.  Write \"last-kbd-macro\"
  315. to refer to the current keyboard macro (as used by \\[call-last-kbd-macro]).
  316.  
  317. The \"Key:\" lines specify key sequences to which the macro is bound,
  318. or \"none\" for no key bindings.
  319.  
  320. You can edit these lines to change the places where the new macro
  321. is stored.
  322.  
  323.  
  324. Format of keyboard macros during editing:
  325.  
  326. Text is divided into \"words\" separated by whitespace.  Except for
  327. the words described below, the characters of each word go directly
  328. as characters of the macro.  The whitespace that separates words
  329. is ignored.  Whitespace in the macro must be written explicitly,
  330. as in \"foo SPC bar RET\".
  331.  
  332.  * The special words RET, SPC, TAB, DEL, LFD, ESC, and NUL represent
  333.    special control characters.  The words must be written in uppercase.
  334.  
  335.  * A word in angle brackets, e.g., <return>, <down>, or <f1>, represents
  336.    a function key.  (Note that in the standard configuration, the
  337.    function key <return> and the control key RET are synonymous.)
  338.    You can use angle brackets on the words RET, SPC, etc., but they
  339.    are not required there.
  340.  
  341.  * Keys can be written by their ASCII code, using a backslash followed
  342.    by up to six octal digits.  This is the only way to represent keys
  343.    with codes above \\377.
  344.  
  345.  * One or more prefixes M- (meta), C- (control), S- (shift), A- (alt),
  346.    H- (hyper), and s- (super) may precede a character or key notation.
  347.    For function keys, the prefixes may go inside or outside of the
  348.    brackets:  C-<down> = <C-down>.  The prefixes may be written in
  349.    any order:  M-C-x = C-M-x.
  350.  
  351.    Prefixes are not allowed on multi-key words, e.g., C-abc, except
  352.    that the Meta prefix is allowed on a sequence of digits and optional
  353.    minus sign:  M--123 = M-- M-1 M-2 M-3.
  354.  
  355.  * The `^' notation for control characters also works:  ^M = C-m.
  356.  
  357.  * Double angle brackets enclose command names:  <<next-line>> is
  358.    shorthand for M-x next-line RET.
  359.  
  360.  * Finally, REM or ;; causes the rest of the line to be ignored as a
  361.    comment.
  362.  
  363. Any word may be prefixed by a multiplier in the form of a decimal
  364. number and `*':  3*<right> = <right> <right> <right>, and
  365. 10*foo = foofoofoofoofoofoofoofoofoofoo.
  366.  
  367. Multiple text keys can normally be strung together to form a word,
  368. but you may need to add whitespace if the word would look like one
  369. of the above notations:  `; ; ;' is a keyboard macro with three
  370. semicolons, but `;;;' is a comment.  Likewise, `\\ 1 2 3' is four
  371. keys but `\\123' is a single key written in octal, and `< right >'
  372. is seven keys but `<right>' is a single function key.  When in
  373. doubt, use whitespace."
  374.   (interactive)
  375.   (error "This mode can be enabled only by `edit-kbd-macro'"))
  376. (put 'edmacro-mode 'mode-class 'special)
  377.  
  378. ;;; Formatting a keyboard macro as human-readable text.
  379.  
  380. (defun edmacro-format-keys (macro &optional verbose)
  381.   (setq macro (edmacro-fix-menu-commands macro))
  382.   (let* ((maps (append (current-minor-mode-maps)
  383.                (list (current-local-map) (current-global-map))))
  384.      (pkeys '(end-macro ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?\C-u
  385.           ?\M-- ?\M-0 ?\M-1 ?\M-2 ?\M-3 ?\M-4 ?\M-5 ?\M-6
  386.           ?\M-7 ?\M-8 ?\M-9))
  387.      (mdigs (nthcdr 13 pkeys))
  388.      (maxkey (if edmacro-eight-bits 255 127))
  389.      (case-fold-search nil)
  390.      (res-words '("NUL" "TAB" "LFD" "RET" "ESC" "SPC" "DEL" "REM"))
  391.      (rest-mac (vconcat macro [end-macro]))
  392.      (res "")
  393.      (len 0)
  394.      (one-line (eq verbose 1)))
  395.     (if one-line (setq verbose nil))
  396.     (when (stringp macro)
  397.       (loop for i below (length macro) do
  398.         (when (>= (aref rest-mac i) 128)
  399.           (incf (aref rest-mac i) (- (lsh 1 23) 128)))))
  400.     (while (not (eq (aref rest-mac 0) 'end-macro))
  401.       (let* ((prefix
  402.           (or (and (integerp (aref rest-mac 0))
  403.                (memq (aref rest-mac 0) mdigs)
  404.                (memq (key-binding (subseq rest-mac 0 1))
  405.                  '(digit-argument negative-argument))
  406.                (let ((i 1))
  407.              (while (memq (aref rest-mac i) (cdr mdigs))
  408.                (incf i))
  409.              (and (not (memq (aref rest-mac i) pkeys))
  410.                   (prog1 (concat "M-" (subseq rest-mac 0 i) " ")
  411.                 (callf subseq rest-mac i)))))
  412.           (and (eq (aref rest-mac 0) ?\C-u)
  413.                (eq (key-binding [?\C-u]) 'universal-argument)
  414.                (let ((i 1))
  415.              (while (eq (aref rest-mac i) ?\C-u)
  416.                (incf i))
  417.              (and (not (memq (aref rest-mac i) pkeys))
  418.                   (prog1 (loop repeat i concat "C-u ")
  419.                 (callf subseq rest-mac i)))))
  420.           (and (eq (aref rest-mac 0) ?\C-u)
  421.                (eq (key-binding [?\C-u]) 'universal-argument)
  422.                (let ((i 1))
  423.              (when (eq (aref rest-mac i) ?-)
  424.                (incf i))
  425.              (while (memq (aref rest-mac i)
  426.                       '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
  427.                (incf i))
  428.              (and (not (memq (aref rest-mac i) pkeys))
  429.                   (prog1 (concat "C-u " (subseq rest-mac 1 i) " ")
  430.                 (callf subseq rest-mac i)))))))
  431.          (bind-len (apply 'max 1
  432.                   (loop for map in maps
  433.                     for b = (lookup-key map rest-mac)
  434.                     when b collect b)))
  435.          (key (subseq rest-mac 0 bind-len))
  436.          (fkey nil) tlen tkey
  437.          (bind (or (loop for map in maps for b = (lookup-key map key)
  438.                  thereis (and (not (integerp b)) b))
  439.                (and (setq fkey (lookup-key function-key-map rest-mac))
  440.                 (setq tlen fkey tkey (subseq rest-mac 0 tlen)
  441.                   fkey (lookup-key function-key-map tkey))
  442.                 (loop for map in maps
  443.                   for b = (lookup-key map fkey)
  444.                   when (and (not (integerp b)) b)
  445.                   do (setq bind-len tlen key tkey)
  446.                   and return b
  447.                   finally do (setq fkey nil)))))
  448.          (first (aref key 0))
  449.          (text (loop for i from bind-len below (length rest-mac)
  450.              for ch = (aref rest-mac i)
  451.              while (and (integerp ch)
  452.                     (> ch 32) (< ch maxkey) (/= ch 92)
  453.                     (eq (key-binding (char-to-string ch))
  454.                     'self-insert-command)
  455.                     (or (> i (- (length rest-mac) 2))
  456.                     (not (eq ch (aref rest-mac (+ i 1))))
  457.                     (not (eq ch (aref rest-mac (+ i 2))))))
  458.              finally return i))
  459.          desc)
  460.     (if (stringp bind) (setq bind nil))
  461.     (cond ((and (eq bind 'self-insert-command) (not prefix)
  462.             (> text 1) (integerp first)
  463.             (> first 32) (<= first maxkey) (/= first 92)
  464.             (progn
  465.               (if (> text 30) (setq text 30))
  466.               (setq desc (concat (subseq rest-mac 0 text)))
  467.               (when (string-match "^[ACHMsS]-." desc)
  468.             (setq text 2)
  469.             (callf substring desc 0 2))
  470.               (not (string-match
  471.                 "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*."
  472.                 desc))))
  473.            (when (or (string-match "^\\^.$" desc)
  474.              (member desc res-words))
  475.          (setq desc (mapconcat 'char-to-string desc " ")))
  476.            (when verbose
  477.          (setq bind (format "%s * %d" bind text)))
  478.            (setq bind-len text))
  479.           ((and (eq bind 'execute-extended-command)
  480.             (> text bind-len)
  481.             (memq (aref rest-mac text) '(return 13))
  482.             (progn
  483.               (setq desc (concat (subseq rest-mac bind-len text)))
  484.               (commandp (intern-soft desc))))
  485.            (if (commandp (intern-soft desc)) (setq bind desc))
  486.            (setq desc (format "<<%s>>" desc))
  487.            (setq bind-len (1+ text)))
  488.           (t
  489.            (setq desc (mapconcat
  490.                (function
  491.                 (lambda (ch)
  492.                   (cond
  493.                    ((integerp ch)
  494.                 (concat
  495.                  (loop for pf across "ACHMsS"
  496.                        for bit in '(18 22 20 23 19 21)
  497.                        when (/= (logand ch (lsh 1 bit)) 0)
  498.                        concat (format "%c-" pf))
  499.                  (let ((ch2 (logand ch (1- (lsh 1 18)))))
  500.                    (cond ((<= ch2 32)
  501.                       (case ch2
  502.                         (0 "NUL") (9 "TAB") (10 "LFD")
  503.                         (13 "RET") (27 "ESC") (32 "SPC")
  504.                         (t
  505.                          (format "C-%c"
  506.                              (+ (if (<= ch2 26) 96 64)
  507.                             ch2)))))
  508.                      ((= ch2 127) "DEL")
  509.                      ((<= ch2 maxkey) (char-to-string ch2))
  510.                      (t (format "\\%o" ch2))))))
  511.                    ((symbolp ch)
  512.                 (format "<%s>" ch))
  513.                    (t
  514.                 (error "Unrecognized item in macro: %s" ch)))))
  515.                (or fkey key) " "))))
  516.     (if prefix (setq desc (concat prefix desc)))
  517.     (unless (string-match " " desc)
  518.       (let ((times 1) (pos bind-len))
  519.         (while (not (mismatch rest-mac rest-mac
  520.                   :end1 bind-len :start2 pos
  521.                   :end2 (+ bind-len pos)))
  522.           (incf times)
  523.           (incf pos bind-len))
  524.         (when (> times 1)
  525.           (setq desc (format "%d*%s" times desc))
  526.           (setq bind-len (* bind-len times)))))
  527.     (setq rest-mac (subseq rest-mac bind-len))
  528.     (if verbose
  529.         (progn
  530.           (unless (equal res "") (callf concat res "\n"))
  531.           (callf concat res desc)
  532.           (when (and bind (or (stringp bind) (symbolp bind)))
  533.         (callf concat res
  534.           (make-string (max (- 3 (/ (length desc) 8)) 1) 9)
  535.           ";; " (if (stringp bind) bind (symbol-name bind))))
  536.           (setq len 0))
  537.       (if (and (> (+ len (length desc) 2) 72) (not one-line))
  538.           (progn
  539.         (callf concat res "\n ")
  540.         (setq len 1))
  541.         (unless (equal res "")
  542.           (callf concat res " ")
  543.           (incf len)))
  544.       (callf concat res desc)
  545.       (incf len (length desc)))))
  546.     res))
  547.  
  548. (defun edmacro-fix-menu-commands (macro)
  549.   (when (vectorp macro)
  550.     (let ((i 0) ev)
  551.       (while (< i (length macro))
  552.     (when (consp (setq ev (aref macro i)))
  553.       (cond ((equal (cadadr ev) '(menu-bar))
  554.          (setq macro (vconcat (subseq macro 0 i)
  555.                       (vector 'menu-bar (car ev))
  556.                       (subseq macro (1+ i))))
  557.          (incf i))
  558.         ;; It would be nice to do pop-up menus, too, but not enough
  559.         ;; info is recorded in macros to make this possible.
  560.         (t
  561.          (error "Macros with mouse clicks are not %s"
  562.             "supported by this command"))))
  563.     (incf i))))
  564.   macro)
  565.  
  566. ;;; Parsing a human-readable keyboard macro.
  567.  
  568. (defun edmacro-parse-keys (string &optional need-vector)
  569.   (let ((case-fold-search nil)
  570.     (pos 0)
  571.     (res []))
  572.     (while (and (< pos (length string))
  573.         (string-match "[^ \t\n\f]+" string pos))
  574.       (let ((word (substring string (match-beginning 0) (match-end 0)))
  575.         (key nil)
  576.         (times 1))
  577.     (setq pos (match-end 0))
  578.     (when (string-match "\\([0-9]+\\)\\*." word)
  579.       (setq times (string-to-int (substring word 0 (match-end 1))))
  580.       (setq word (substring word (1+ (match-end 1)))))
  581.     (cond ((string-match "^<<.+>>$" word)
  582.            (setq key (vconcat (if (eq (key-binding [?\M-x])
  583.                       'execute-extended-command)
  584.                       [?\M-x]
  585.                     (or (car (where-is-internal
  586.                           'execute-extended-command))
  587.                     [?\M-x]))
  588.                   (substring word 2 -2) "\r")))
  589.           ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
  590.             (progn
  591.               (setq word (concat (substring word (match-beginning 1)
  592.                             (match-end 1))
  593.                      (substring word (match-beginning 3)
  594.                             (match-end 3))))
  595.               (not (string-match
  596.                 "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
  597.                 word))))
  598.            (setq key (list (intern word))))
  599.           ((or (equal word "REM") (string-match "^;;" word))
  600.            (setq pos (string-match "$" string pos)))
  601.           (t
  602.            (let ((orig-word word) (prefix 0) (bits 0))
  603.          (while (string-match "^[ACHMsS]-." word)
  604.            (incf bits (lsh 1 (cdr (assq (aref word 0)
  605.                         '((?A . 18) (?C . 22)
  606.                           (?H . 20) (?M . 23)
  607.                           (?s . 19) (?S . 21))))))
  608.            (incf prefix 2)
  609.            (callf substring word 2))
  610.          (when (string-match "^\\^.$" word)
  611.            (incf bits (lsh 1 22))
  612.            (incf prefix)
  613.            (callf substring word 1))
  614.          (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
  615.                         ("LFD" . "\n") ("TAB" . "\t")
  616.                         ("ESC" . "\e") ("SPC" . " ")
  617.                         ("DEL" . "\177")))))
  618.            (when found (setq word (cdr found))))
  619.          (when (string-match "^\\\\[0-7]+$" word)
  620.            (loop for ch across word
  621.              for n = 0 then (+ (* n 8) ch -48)
  622.              finally do (setq word (vector n))))
  623.          (cond ((= bits 0)
  624.             (setq key word))
  625.                ((and (= bits (lsh 1 23)) (stringp word)
  626.                  (string-match "^-?[0-9]+$" word))
  627.             (setq key (loop for x across word collect (+ x bits))))
  628.                ((/= (length word) 1)
  629.             (error "%s must prefix a single character, not %s"
  630.                    (substring orig-word 0 prefix) word))
  631.                ((and (/= (logand bits (lsh 1 22)) 0) (stringp word)
  632.                  (string-match "[@-_.a-z?]" word))
  633.             (setq key (list (+ bits (- (lsh 1 22))
  634.                        (if (equal word "?") 127
  635.                          (logand (aref word 0) 31))))))
  636.                (t
  637.             (setq key (list (+ bits (aref word 0)))))))))
  638.     (when key
  639.       (loop repeat times do (callf vconcat res key)))))
  640.     (when (and (>= (length res) 4)
  641.            (eq (aref res 0) ?\C-x)
  642.            (eq (aref res 1) ?\()
  643.            (eq (aref res (- (length res) 2)) ?\C-x)
  644.            (eq (aref res (- (length res) 1)) ?\)))
  645.       (setq res (subseq res 2 -2)))
  646.     (if (and (not need-vector)
  647.          (loop for ch across res
  648.            always (and (integerp ch)
  649.                    (let ((ch2 (logand ch (lognot (lsh 1 23)))))
  650.                  (and (>= ch2 0) (<= ch2 127))))))
  651.     (concat (loop for ch across res
  652.               collect (if (= (logand ch (lsh 1 23)) 0)
  653.                   ch (+ ch 128))))
  654.       res)))
  655.  
  656. ;;; The following probably ought to go in macros.el:
  657.  
  658. ;;;###autoload
  659. (defun insert-kbd-macro (macroname &optional keys)
  660.   "Insert in buffer the definition of kbd macro NAME, as Lisp code.
  661. Optional second arg KEYS means also record the keys it is on
  662. \(this is the prefix argument, when calling interactively).
  663.  
  664. This Lisp code will, when executed, define the kbd macro with the same
  665. definition it has now.  If you say to record the keys, the Lisp code
  666. will also rebind those keys to the macro.  Only global key bindings
  667. are recorded since executing this Lisp code always makes global
  668. bindings.
  669.  
  670. To save a kbd macro, visit a file of Lisp code such as your `~/.emacs',
  671. use this command, and then save the file."
  672.   (interactive "CInsert kbd macro (name): \nP")
  673.   (let (definition)
  674.     (if (string= (symbol-name macroname) "")
  675.     (progn
  676.       (setq definition (format-kbd-macro))
  677.       (insert "(setq last-kbd-macro"))
  678.       (setq definition (format-kbd-macro macroname))
  679.       (insert (format "(defalias '%s" macroname)))
  680.     (if (> (length definition) 50)
  681.     (insert " (read-kbd-macro\n")
  682.       (insert "\n  (read-kbd-macro "))
  683.     (prin1 definition (current-buffer))
  684.     (insert "))\n")
  685.     (if keys
  686.     (let ((keys (where-is-internal macroname nil)))
  687.       (while keys
  688.         (insert (format "(global-set-key %S '%s)\n" (car keys) macroname))
  689.         (setq keys (cdr keys)))))))
  690.  
  691. (provide 'edmacro)
  692.  
  693. ;;; edmacro.el ends here
  694.  
  695.